Network Support Library/RoseWare - Network Support Library.iso/apidev/netman.arc/FOLLOWER.PAS

Pascal/Delphi Source File | 1989-06-30 | 8KB | 479 lines

{$ifdef CPU87}
  {$N+}
{$endif}

program Follower;

uses Graph, Crt, Drivers, Fonts;

const Choir = 5;
      Bass = 200;
      Treble = 1500;
      Tempo = 2;
      Rhythm = 40;
      Path='.';
      Painting = 'FRACTAL.DAT';
      Framework = 'VALUES.DAT';

const No_Error = $00;
      Not_Found = $02;
      Access_Denied = $05;

const Read_Only = $00;
      Write_Only = $01;
      Read_Write = $02;
      Deny_All = $10;
      Deny_Write = $20;
      Deny_Read = $30;
      Deny_None = $40;

type Count_Type = byte;
     Size_Type = word;

{$ifdef CPU87}
     Real_Type = single;
{$else}
     Real_Type = real;
{$endif}

type Header = record
                Sound: boolean;
                AtV,
                ToV: Size_Type;
              end;

type Shape = record
               Flux: Header;
               H,
               V: Size_Type;
               Most: Count_Type;
               BitPixel,
               PixelByte: byte;
               ByteLine: word;
               Top,
               Left,
               YInc,
               XInc: Real_Type;
               Interlace: boolean;
             end;

var PriorExit: pointer;

{$f+}
procedure Terminate;
{$f-}

begin
CloseGraph;
ExitProc:=PriorExit;
end;

const Colors = 3;

procedure Initiate;

const Mode: integer = CGAC0;
      Device: integer= CGA;

var Result: integer;

begin
Result:=RegisterBGIdriver(@CGADriverProc);
InitGraph(Device, Mode, Path);
Result:=RegisterBGIfont(@GothicFontProc);
Result:=RegisterBGIfont(@TriplexFontProc);
Result:=RegisterBGIfont(@SmallFontProc);
PriorExit:=ExitProc;
ExitProc:=@Terminate;
end;

procedure Inculcate;

type ColorType = 1..Colors;

var Hue: array[ColorType] of byte;

procedure Adjust;

const BackGround = 7;

var Index,
    Cycle: ColorType;
    Group: array[ColorType] of byte;

begin
Randomize;
SetBkColor(Random(Background));
for Cycle:=1 to Colors
do Group[Cycle]:=Cycle;
for Cycle:=Colors downto 1
do begin
   Index:=Random(Cycle) + 1;
   Hue[Cycle]:=Group[Index];
   Move(Group[Index + 1], Group[Index], Colors - Index);
   end;
end;

const AtH = 159;
      AtV = 66;
      Offset = 40;
      FontSize = 4;
      TitleSize = 5;
      NameSize = 1;

type Axes = (X,Y);
     Pair = array[Axes] of shortint;

var Height,
    Cycle: byte;

const Credit: string = 'Mandelbrot Set';
      Shift: array[1..8] of Pair = ((-1,-1),(0,-1),(1,1),
                                    (-1,0),(1,0),
                                    (-1,1),(0,1),(1,1));

begin
Adjust;
SetColor(Hue[1]);
SetTextJustify(CenterText, CenterText);
SetTextStyle(GothicFont, HorizDir, TitleSize);
for Cycle:=1 to 8
do OutTextXY(AtH + Shift[Cycle][X], AtV + Shift[Cycle][Y], Credit);
SetColor(Hue[2]);
OutTextXY(AtH, AtV, Credit);

SetColor(Hue[3]);
SetTextStyle(TriplexFont, HorizDir, FontSize);
OutTextXY(AtH, AtV - Offset, 'GWNet');

SetTextStyle(DefaultFont, HorizDir, NameSize);
OutTextXY(AtH, AtV + Offset, 'The Mad Programmer strikes again!');
end;

var Seed: Shape;

procedure Anticipate;

procedure Respond;

const Escape = #27;

var Key: char;

begin
while Keypressed
do begin
   Key:=ReadKey;
   if Key=Escape
   then Halt;
   end;
end;

type States = (Idle, Busy);

procedure Report(Now: States);

function NewHue: byte;

const Hue: byte = 0;

begin
if Hue=Colors
then Hue:=1
else Inc(Hue);
NewHue:=Hue;
end;

const Off = 0;
      Left = 0;
      LowLine = 189;
      FontSize = 4;

type Note = string[10];

const Message: array[States] of Note = ('waiting...',
                                        'working...');

begin
SetTextStyle(SmallFont, HorizDir, FontSize);
SetTextJustify(LeftText, TopText);
SetColor(Off);
OutTextXY(Left, LowLine, Message[Pred(Now)]);
SetColor(NewHue);
OutTextXY(Left, LowLine, Message[Now]);
end;

const Time = 500;

var Notice: file of Shape;

begin
Report(Idle);
Assign(Notice, Framework);
FileMode:= Read_Write + Deny_None;
repeat
  Respond;
  Delay(Time);
  {$i-}
  Reset(Notice);
  {$i+}
until (IOResult = No_Error);
Read(Notice, Seed);
Close(Notice);
Report(Busy);
end;

procedure Cultivate;

var Once: boolean;
    Eye: file of Header;

function Work: boolean;

const Front = 0;

begin
FileMode:=Read_Write + Deny_All;
repeat
  {$i-}
  Reset(Eye);
  {$i+}
until (IOResult = No_Error);
Read(Eye, Seed.Flux);
Work:=false;
with Seed
do begin
   if Once
   then Dec(Flux.ToV);
   if Flux.ToV = 0
   then begin
        Close(Eye);
        repeat
          Erase(Eye);
        until (IOResult = No_Error);
        end
   else begin
        if Flux.AtV > 0
        then begin
             Dec(Flux.AtV);
             Work:=true;
             end;
        Seek(Eye, Front);
        Write(Eye, Flux);
        Close(Eye);
        end;
   end;
end;

type Pixels = array[byte] of byte;
     Count_Array = array[byte] of Count_Type;

var Span,
    Base,
    Scale,
    Middle: word;
    Map: real;
    Innate: ^Pixels;
    Zone: ^Count_Array;
    Canvas: file;

procedure Prepare;

var Range: word;

const Height = 200;

begin
Assign(Eye, Framework);
Assign(Canvas, Painting);
with Seed
do begin
   Middle:=V div 2;
   Map:=Height / V;
   Range:=(Treble - Bass) div Choir;
   Scale:=Range div Most;
   Base:=Bass + Range * Random(Choir);
   Span:=SizeOf(Count_Type) * H;
   GetMem(Zone, Span);
   GetMem(Innate, ByteLine);
   FileMode:=Write_Only + Deny_None;
   Reset(Canvas, ByteLine);
   end;
SetWriteMode(XORPut);
SetColor(Random(Colors) + 1);
end;

procedure Conclude;

begin
Close(Canvas);
FreeMem(Zone, Span);
FreeMem(Innate, Seed.ByteLine);
SetWriteMode(NormalPut);
ClearDevice;
end;

procedure Abandon;

var Key: char;

begin
NoSound;
Conclude;
while KeyPressed
do Key:=ReadKey;
Halt;
end;

procedure Develop;

procedure Convert;

var Merge,
    Inner: byte;
    Cycle: word;
    Index: Size_Type;

begin
Cycle:=0;
Index:=Seed.H;
with Seed
do repeat
     for Inner:=1 to PixelByte
     do begin
    Merge:=Merge shl BitPixel or (Most - Zone^[Index]);
    Dec(Index);
        end;
     Innate^[Cycle]:=Merge;
     Inc(Cycle);
   until Cycle=ByteLine;
end;

procedure Gauge;

const Left= 0;
      Right= 319;

const Fore: word = 0;
      Rear: word = 0;
      PreFore: word = 0;
      PreRear: word = 0;

begin
with Seed.Flux
do begin
   if Once
   then Rectangle(Left, PreFore, Right, PreRear);
   Fore:=Trunc(AtV * Map);
   Rear:=Trunc(ToV * Map);
   end;
Rectangle(Left, Fore, Right, Rear);
PreFore:=Fore;
PreRear:=Rear;
end;

var Offset: word;

const Single = 1;

begin
Convert;
with Seed
do if Interlace
   then begin
        Offset:=Flux.AtV div 2;
        if Odd(Flux.AtV)
        then Seek(Canvas, Middle + Offset)
        else Seek(Canvas, Offset)
        end
   else Seek(Canvas, Flux.AtV);
BlockWrite(Canvas, Innate^, Single);
Gauge;
end;

var ZR,
    ZI,
    ZR2,
    ZI2: Real_Type;

function Chaotic:boolean;

begin
ZR2:=ZR * ZR;
ZI2:=ZI * ZI;
Chaotic:=(ZR2 + ZI2 < 4);
end;

var I: Count_Type;

function Note: word;

begin
Note:=Trunc(Base + I * Scale);
end;

procedure Sing;

const Cycle: word = 0;
      Duration: word = 0;

begin
Inc(Cycle);
if Cycle=Rhythm
then begin
     Cycle:=0;
     Duration:=(Rhythm shr Tempo) shl Random(Tempo);
     Sound(Note);
     end;
if Cycle = Duration
then NoSound;
end;

var X: Size_Type;
    CR,
    CI: Real_Type;

begin
Prepare;
Once:=false;
while Work
do with Seed
   do begin
      X:=H;
      CR:=Left;
      CI:=Top - (Flux.AtV * YInc);
      repeat
         ZR:=CR;
         ZI:=CI;
         I:=1;
         while Chaotic and (I < Most)
         do begin
            ZR:=ZR2 - ZI2 + CR;
            ZI:=2 * ZR * ZI + CI;
            Inc(I);
            end;
         Dec(X);
         Zone^[X]:=I;
         CR:=CR + XInc;
         if Flux.Sound
         then Sing;
      until (X=0);
      Develop;
      if KeyPressed
      then Abandon;
      Once:=true;
      end;
Conclude;
end;

const EndOfTime = false;

begin
Initiate;
repeat
  Inculcate;
  Anticipate;
  Cultivate;
until EndOfTime;
{Terminate;}
end.